home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / make.lisp < prev    next >
Encoding:
Text File  |  1994-05-07  |  13.9 KB  |  408 lines
  1. ;;; -*-  Mode: Lisp; Package: MAKE; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;; Copyright William F. Schelter 1989.
  3.  
  4. ;; The author expressly permits copying and alteration of this file,
  5. ;; provided any modifications are clearly labeled, and this notice is
  6. ;; preserved.   The author provides no warranty and this software is
  7. ;; provided on an 'as is' basis.
  8. (in-package "MAKE" :use '("LISP") #+gcl :external #+gcl 11
  9.         #+gcl :internal #+gcl 79)
  10.  
  11. (export '(make system-load system-compile))
  12. (provide "MAKE")
  13. ;;;  *******  Description of Make Facility ************
  14. ;;  We provide a simple MAKE facility to allow
  15. ;;compiling and loading of a tree of files
  16. ;;If the tree is '(a b (d e g h) i)
  17. ;;   a will be loaded before b is compiled,
  18. ;;   b will be loaded before d, e, g, h are compiled
  19. ;;   d e g h will be loaded before i is compiled.
  20.  
  21. ;;  A record is kept of write dates of loaded compiled files, and a file
  22. ;;won't be reloaded if it is the same version (unless a force flag is t).
  23.  
  24. ;;Thus if you do (make :uinfor) twice in a row, the second one would not
  25. ;;load anything.  NOTE: If you change a, and a macro in it would affect
  26. ;;b, b still will not be recompiled.  You must choose the :recompile t
  27. ;;option, to force the recompiling if you change macro files.
  28. ;;Alternately you may specify dependency information (see :depends below).
  29.  
  30.  
  31. ;;****** Sample file which when loaded causes system ALGEBRA 
  32. ;;              to be compiled and loaded ******
  33.  
  34. ;;(require "MAKE")
  35. ;;(use-package "MAKE")
  36. ;;(setf (get :algebra :make) '(a b (d e) l))
  37. ;;(setf (get :algebra :source-path) "/usr2/wfs/algebra/foo.lisp")
  38. ;;(setf (get :algebra :object-path) "/usr2/wfs/algebra/o/foo.o")
  39. ;;(make :algebra :compile t)
  40.  
  41. ;;  More complex systems may need to do some special operations
  42. ;;at certain points of the make.  
  43. ;;the tree of files may contain some keywords which have special meaning.
  44. ;;eg. '(a b (:progn (gbc) (if make::*compile*
  45. ;;                                  (format t "A and B finally compiled")))
  46. ;;          (:load-source h i)
  47. ;;          (d e) l)
  48.  
  49. ;;then during the load and compile phases the function (gbc) will be
  50. ;;called after a and b have been acted on, and during the compile phase
  51. ;;the message about "A and B finally.." will be printed.
  52. ;;the lisp files h and i will be loaded after merging the paths with 
  53. ;;the source directory.  This feature is extensible: see the definitions
  54. ;;of :load-source and :progn.
  55.  
  56. ;;  The keyword feature is extensible, and you may specify what 
  57. ;;happens during the load or compile phase for your favorite keyword.
  58. ;;To do this look at the definition of :progn, and :load-source
  59. ;;in the source for make.
  60.  
  61.  
  62. ;;Dependency feature:
  63.  
  64. ;;   This make NEVER loads or compiles files in an order different from
  65. ;;that specified by the tree.  It will omit loading files which are
  66. ;;loaded and up to date, but if two files are out of date, the first (in
  67. ;;the printed representation of the tree), will always be loaded before
  68. ;;the second.  A consequence of this is that circular dependencies can
  69. ;;never occur.
  70. ;;
  71. ;;  If the :make tree contains (a b c d (:depends (c d) (a b))) then c
  72. ;;and d depend on a and b, so that if a or b need recompilation then c
  73. ;;and d will also be recompiled.  Thus the general form of a :depends
  74. ;;clause is (:depends later earlier) where LATER and EARLIER are either
  75. ;;a single file or a list of files. Read it as LATER depends on EARLIER.
  76. ;;A declaration of a (:depends (c) (d)) would have no effect, since the
  77. ;;order in the tree already rules out such a dependence.
  78.  
  79. ;;  An easy way of specifying a linear dependence is by using :serial.
  80. ;;The tree (a (:serial b c d) e)  is completely equivalent to the tree
  81. ;;(a b c d e (:depends c b)(:depends d (b c))), but with a long list of
  82. ;;serial files, it is inconvenient to specify them in the
  83. ;;latter representation.
  84.  
  85. ;;A common case is a set of macros whose dependence is serial followed by a set
  86. ;;of files whose order is unimportant.  A conventient way of building that
  87. ;;tree is
  88. ;;
  89. ;;(let ((macros '(a b c d))
  90. ;;      (files '(c d e f g)))
  91. ;;  `((:serial ,@ macros)
  92. ;;    ,files
  93. ;;    (:depends ,files ,macros)))
  94.  
  95. ;;  The depends clause may occur anywhere within the tree, since
  96. ;;an initial pass collects all dependency information.
  97.  
  98. ;;  Make takes a SHOW keyword argument.  It is almost impossible to simulate
  99. ;;all the possible features of make, for show.  Nonetheless, it is good
  100. ;;to get an idea of the compiling and loading sequence for a new system.
  101. ;;As a byproduct, you could use the output, as a simple sequence of calls
  102. ;;to compile-file and load, to do the required work, when make is not around
  103. ;;to help.
  104.  
  105.  
  106. ;;*****  Definitions ********
  107. (defvar *files-loaded* nil)
  108. (defvar *show-files-loaded* nil) ;only for show option
  109. (defvar *load* nil "Will be non nil inside load-files")
  110. (defvar *compile* nil "Bound by compile-files to t")
  111. (defvar *depends* nil)
  112. (defvar *depends-new* nil)
  113. (defvar *force* nil)
  114. (defvar *when-compile* nil "Each compile-file evals things in this list and sets it to nil")
  115. #+kcl(defvar *system-p* nil)
  116. (defvar *compile-file-function* 'make-compile-file)
  117. (defvar *load-function* 'make-load-file)
  118. (defvar show nil)
  119. (defvar *cflags* #-kcl nil
  120.   #+kcl '(:system-p  *system-p*))
  121.  
  122.  
  123. ;;this is the main entry point
  124.  
  125. (defun make (system &key recompile compile batch object-path source-path
  126.             show proclaims
  127.             &aux files *depends* *when-compile*
  128.             *show-files-loaded*
  129.             #+gcl (*load-fn-too* proclaims)
  130.  
  131.             )
  132.  
  133.   "SYSTEM is a tree of files, or a symbol with :make property.  It
  134. loads all file files in system.  If COMPILE it will try to compile
  135. files with newer source versions than object versions, before loading.
  136. If RECOMPILE it will recompile all files.  This is equivalent to deleting all
  137. objects and using :compile t.   SOURCE-PATH is merged with the name given
  138. in the files list, when looking for a file to compile.  OBJECT-PATH is
  139. merged with the name in the files list, when looking for a file to
  140. load.  If SYSTEM is a symbol, then a null OBJECT-PATH would be set to
  141. the :object-path property of SYSTEM.  Similarly for :source-path"
  142.  
  143.   (declare (special object-path source-path show)) batch
  144.   (cond ((symbolp system)
  145.      (or object-path (setf object-path (get system :object-path)))
  146.      (or source-path (setf source-path (get system :source-path)))
  147.      (setf files (get system :make))
  148.      (or files
  149.          (if (get system :files)
  150.          (error "Use :make property, :files property is obssolet{!")))
  151.      )
  152.     (t (setf files system)))
  153.   #+gcl (when proclaims (compiler::emit-fn t) (compiler::setup-sys-proclaims))
  154.   (let (#+lispm ( si::inhibit-fdefine-warnings
  155.          (if batch :just-warn  si::inhibit-fdefine-warnings)))
  156.     (let ((*depends*  (if (or compile recompile) (get-depends system)))
  157.       *depends-new*)
  158.     (dolist (v files)
  159.         (when (or compile recompile)
  160.             (compile-files v recompile))
  161.         (load-files v recompile)))
  162.     #+gcl
  163.     (if proclaims (compiler::write-sys-proclaims))
  164.     ))
  165.  
  166. (defun system-load (system-name &rest names)
  167.   "If :infor is a system, (system-load :uinfor joe betty) will load
  168. joe and betty from the object-path for :uinfor"
  169.   (load-files names t (get system-name :object-path)))
  170.  
  171. (defun system-compile (system-name &rest names)
  172.                   
  173.   "If :iunfor is a system, (system-compile :uinfor joe) will in the
  174. source path for joe and compile him into the object path for :uinfor"
  175.   (compile-files names t :source-path
  176.          (get system-name :source-path) :object-path
  177.          (get system-name :object-path)))
  178.  
  179. (defun get-depends (system-name &aux result)
  180.   (dolist (v (get system-name :make))
  181.   (cond    ((atom v) )
  182.        ((eq (car v) :serial)
  183.         (do ((w (reverse (cdr v))(cdr w)))
  184.         ((null (cdr w)))
  185.         (push (list (car w) (cdr w)) result)))
  186.        ((eq (car v) :depends)
  187.         (push (cdr v) result ))))
  188.     result)
  189.        
  190. #+kcl
  191. (setq si::*default-time-zone* 6)
  192.  
  193. (defun print-date (&optional(stream *standard-output*)
  194.                 (time (get-universal-time)))
  195.   (multiple-value-bind (sec min hr day mon yr wkday)
  196.                (decode-universal-time time)
  197.     (format stream "~a ~a ~a ~d:~2,'0d:~2,'0d ~a"
  198.         (nth wkday '( "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
  199.         (nth (1- mon) '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
  200.                "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
  201.         day
  202.         hr min sec yr)))
  203.            
  204. ;;This is an awfully roundabout downcase, but some machines
  205. ;;like symbolics swap cases on the pathname, so we have to do an extra 
  206. ;;swap!!
  207. (defun lowcase (na &aux (*print-case* :downcase))
  208.   (pathname-name (pathname  (format nil "~a" na))))
  209.  
  210. (defun our-merge (name path &optional ign  ) ign
  211.   #+lispm (setq name (string-upcase (string name)))
  212.     (make-pathname :name (string name)
  213.            :type (pathname-type path)
  214.            :version (pathname-version path)
  215.            :host (pathname-host path)
  216.            :directory (pathname-directory path)))
  217.  
  218.  
  219. #+kcl
  220. (setf (get :link 'load)
  221.       #'(lambda (path to-link)
  222.       (declare (special object-path))
  223.       (si::faslink (our-merge    (lowcase  path) object-path)
  224.                to-link)))
  225.  
  226. (setf (get :link 'compile)
  227.       #'(lambda (path to-link) 
  228.        to-link
  229.       (compile-files  path *force*)))
  230.  
  231. (setf (get :progn 'load)
  232.       #'(lambda (&rest args)
  233.       (eval (cons 'progn args))))
  234.  
  235. (setf (get :progn 'compile) (get :progn 'load))
  236.  
  237. (setf (get :load-source 'load)
  238.       #'(lambda (&rest args)
  239.       (declare (special source-path))
  240.       (load-files args *force* source-path)))
  241.  
  242. (setf (get :load-source-when-compile 'compile)
  243.       (get :load-source 'load))
  244.  
  245. ;;should nott use :lisp anymore
  246. (setf (get :lisp 'load)
  247.       #'(lambda (x) (error "please replace :lisp by :load-source")))
  248.  
  249. (setf (get :serial 'load) #'(lambda (&rest l)(load-files l)))
  250. (setf (get :serial 'compile)
  251.       #'(lambda (&rest l)
  252.       (dolist (v l)
  253.         (compile-files v)
  254.         (load-files v))))
  255.  
  256.  
  257. (defun load-files (files &optional (*force* *force*) (object-path object-path)
  258.              &aux path tem (*load* t))
  259.   (declare (special object-path source-path *force* show))
  260.   (cond ((atom files)
  261.      (setq path (object files))
  262.      (cond (show
  263.         (unless (member path *show-files-loaded* :test 'equalp)
  264.             (push path *show-files-loaded*)
  265.             (format t "~%(LOAD ~s)" (namestring path))))
  266.            ((null *load-function*))
  267.            ((or *force*
  268.             (or (not (setq tem
  269.                    (member path *files-loaded*
  270.                        :test 'equalp :key 'car)))
  271.             (> (file-write-date  path) (cdr (car tem)))))
  272.         (funcall *load-function* files)
  273.         (push (cons path (file-write-date path)) *files-loaded*))))
  274.     ((keywordp (car files))
  275.      (let ((fun (get (car files) 'load)))
  276.        (cond (fun (apply fun (cdr files))))))
  277.     (t (dolist (v files) (load-files v *force*  object-path)))))
  278.  
  279.  
  280. (defun file-date (file)
  281.   (if (probe-file file) (or (file-write-date file) 0) 0))
  282.  
  283. (defun source (file)
  284.   (declare (special source-path))
  285.    (our-merge  (lowcase file) source-path))
  286.  
  287. (defun object (file)
  288.   (declare (special object-path))
  289.    (our-merge  (lowcase file) object-path))
  290.  
  291.  
  292. ;;for lisp machines, and others where checking date is slow, this
  293. ;;we should try to cache some dates, and then remove them as we do
  294. ;;things like compile files...
  295.  
  296. (defun file-out-dated (file)
  297.   (let ((obj-date (file-date (object file))))
  298.     (or (<= obj-date (file-date (source file)))
  299.     (dolist (v *depends*)
  300.         (cond ((or (and (consp (car v))
  301.                 (member file (car v)))
  302.                (eq (car v) file))
  303.                (dolist (w (if (consp (second v))
  304.                       (second v) (cdr v)))
  305.                    (cond ((or (<= obj-date (file-date (source w)))
  306.                       (member w *depends-new*))
  307.                       (return-from file-out-dated t))))))))))
  308.  
  309.  
  310. (defun make-compile-file ( l)
  311.   (format t "~&Begin compile ~a at ~a~%" l (print-date nil))
  312.   (dolist (v *when-compile*) (eval v))
  313.   (setq *when-compile* nil)
  314.   ;;Franz excl needs pathnames quoted, and some other lisp
  315.   ;;would not allow an apply here.  Sad.
  316.   (eval `(compile-file ',(source l) :output-file ',(object l)
  317.                ,@ *cflags*))
  318.   (format t "~&End compile ~a at ~a~%" l (print-date nil))
  319.  
  320.   )
  321.  
  322. (defvar *load-fn-too* nil)
  323. (defun make-load-file (l)
  324.   (let ((na (object l)))
  325.     (load na)
  326.     (if (and *load-fn-too*
  327.          (probe-file
  328.           (setq na
  329.             (our-merge (lowcase l) (merge-pathnames "foo.fn" na)))))
  330.     (load na))
  331.     
  332.   
  333.   ))
  334.  
  335. ;;these are versions which don't really compile or load files, but
  336. ;;do create a new "compiled file" and "fake load" to test date mechanism.
  337. #+debug
  338. (defun make-compile-file (file)
  339.   (format t "~%Fake Compile ~a" (namestring (source file)))
  340.     (dolist (v *when-compile*) (eval v))  (setq *when-compile* nil)
  341.   (with-open-file (st (object file) :direction :output)
  342.           (format st "(print (list 'hi))")))
  343. #+debug
  344. (defun make-load-file (l)
  345.   (format t "~%Fake loading ~a" (namestring(object l))))
  346.  
  347.  
  348.           
  349.  
  350. (defun compile-files (files &optional (*force*  *force*)
  351.                 &key (source-path source-path)
  352.                 (object-path object-path)
  353.                 &aux
  354.                 (*compile* t) )
  355.   (declare (special object-path source-path *force* show))
  356.   (cond ((atom files)
  357.      (when (or *force*  (file-out-dated files))
  358.           (push files  *depends-new*)
  359.            (cond
  360.         (show
  361.          (format t "~%(COMPILE-FILE ~s)" (namestring (source files))))
  362.         (t
  363.          (and *compile-file-function*
  364.               (funcall *compile-file-function* files))
  365.          ))))
  366.     ((keywordp (car files))
  367.      (let ((fun (get (car files) 'compile)))
  368.        (if fun (apply fun (cdr files)))))
  369.     (t (dolist (v files) (compile-files v *force*)))))
  370.  
  371. ;;Return the files for SYSTEM 
  372.  
  373. (defun system-files (system &aux *files*)
  374.   (declare (special *files*))
  375.   (let ((sys (get system :make)))
  376.     (get-files1 sys))
  377.   (nreverse *files*))
  378.  
  379.    
  380. (defun get-files1 (sys)
  381.   (declare (special *files*))
  382.   (cond ((and sys (atom sys) )(pushnew sys *files*))
  383.     ((eq (car sys) :serial) (get-files1 (cdr sys)))
  384.     ((keywordp (car sys)))
  385.     (t (dolist (v sys) (get-files1 v)))))
  386.  
  387.   
  388. (defmacro make-user-init (files &aux (object-path
  389.                       (if (boundp 'object-path) object-path
  390.                       "foo.o")))
  391.   (declare (special object-path))
  392.     `(progn
  393.        (clines "void init_or_load1 ();
  394. #define init_or_load(fn,file) do {extern int fn(); init_or_load1(fn,file);}  while(0)
  395.  
  396. user_init{") ,@
  397.      (sloop::sloop for x  in files
  398.     for f  = (substitute #\- #\_ (lowcase x))
  399.     for ff =  (namestring (truename (object x)))
  400.     collect
  401.     `(clines ,(Format nil "init_or_load(init_~a,\"~a\");" f ff)))
  402.        (clines "}")))
  403.  
  404.     
  405.       
  406.   
  407.  
  408.